home *** CD-ROM | disk | FTP | other *** search
/ Business Shareware / Business Shareware.iso / start / database / lib194 / picklist.prg < prev    next >
Encoding:
Text File  |  1993-02-18  |  66.5 KB  |  1,837 lines
  1. *-------------------------------------------------------------------------------
  2. *-- Program..: PICKLIST.PRG 
  3. *-- Date.....: 01/27/1993
  4. *-- Notes....: This new (as of November, 1992) section of the DUFLP library is
  5. *--            designed to be a place where a variety of picklist routines
  6. *--            will be stored. You can ... ahem ... pick and choose the one(s)
  7. *--            you need from here.
  8. *-- WARNING..: Do not save changes with WordStar 5.5 Non_Document mode --
  9. *--            the diacritical characters in the DIACRIT procedure below
  10. *--            will not be saved properly (WordStar doesn't like high ASCII 
  11. *--            characters ...)
  12. *-------------------------------------------------------------------------------
  13.  
  14. FUNCTION Pick1
  15. *-------------------------------------------------------------------------------
  16. *-- Programmer..: Kenneth W. Holloway (HollowayK on BORBBS)
  17. *-- Date........: 11/06/1992
  18. *-- Notes.......: Pick List.
  19. *-- Written for.: dBASE IV, 1.5
  20. *-- Rev. History: 08/12/1992 0.0 - Original version (KWH)
  21. *--               09/11/1992 0.1 - (KWH) Added color settings (x_ClrP*) that
  22. *--                                 were Ass-U-Med to be defined elsewhere.
  23. *--               09/16/1992 0.2 - (KWH) Added "set key to" at end of function.
  24. *--                                 (BORLAND: What happened to set("KEY")?!?!)
  25. *--               10/14/1992 0.3 - Added (KenMayer) ability to pass colors
  26. *--                                to program ... removed settings for
  27. *--                                alias, order, key. The reason is a lack
  28. *--                                of stack space to call routine, can only send
  29. *--                                x number of parms. The programmer must
  30. *--                                set the database (select .../Use ...), 
  31. *--                                order, and key (set key...) before calling
  32. *--                                this routine, and then reset to prior setting
  33. *--                                (if needed). 
  34. *--               10/15/1992 0.4 - (KWH) Added code for Tab/Shift Tab. Put the
  35. *--                                 setting for key back in, as it is required
  36. *--                                 for proper SEEKing with SET KEY in effect.
  37. *--               10/19/1992 0.5 - (KWH) Several changes inspired by JOEY:
  38. *--                 ■ Now uses setting of SET BORDER TO when drawing borders.
  39. *--                 ■ Bell only sounds when SET BELL is ON.
  40. *--                 ■ Added code for {Home} and {End}.
  41. *--               11/06/1992 0.6 - (KWH) Optimization inspired by KELVIN:
  42. *--                 ■ Removed repetitive recalculation of PICTURE clause
  43. *--                 ■ Removed some dead code
  44. *--                 ■ Added a logical variable for main loop, instead of four
  45. *--                     .and.ed expressions
  46. *-- Calls.......: ColorBrk()           Function in PROC.PRG
  47. *-- Called by...: Any
  48. *-- Usage.......: Pick1(cTitle,cDisplay,cReturn[,cKey[,nFromRow,nFromCol
  49. *--                           [,nToRow,nToCol[,cColor1[,cColor2]]]]])
  50. *-- Example.....: ? Pick1("Client Name","NAME","JOB_CODE","",5,10,20,55,;
  51. *--                          cColor1,cColor2)
  52. *-- Returns.....: Specified expression, using macro substitution.
  53. *-- Parameters..: cTitle    = Title to be displayed above PickList
  54. *--               cDisplay  = Expression to display, using macro substitution
  55. *--                 Note: If cDisplay includes any chr(29)'s (), the Tab and
  56. *--                       Shift Tab keys can be used to highlight/unhighlight
  57. *--                       everything up to the next/previous chr(29).
  58. *--               cReturn   = Expression to return, using macro substitution
  59. *--               cKey      = Expression for SET KEY TO
  60. *--               nFromRow  \ Upper left corner
  61. *--               nFromCol  / of PickList window
  62. *--               nToRow    \ Lower right corner
  63. *--               nToCol    / of PickList window
  64. *--               cColor1   = message,title,box 
  65. *--               cColor2   = highlight,selected
  66. *--                           Both cColor1, and cColor2 use specific color
  67. *--                           settings of <Foreground>/<Background>  for each
  68. *--                           part of the parm. For example, cColor1 might
  69. *--                           look like:  rg+/gb,w+/b,rg+/gb
  70. *--                           Definitions:
  71. *--                            message   = unselected items in picklist (w+/rb)
  72. *--                            title     = title at top of window (w+/rb)
  73. *--                            box       = border (rg+/rb)
  74. *--                            highlight = highlighted item (g+/n)
  75. *--                            selected  = selected character(s) (r+/n)
  76. *-------------------------------------------------------------------------------
  77.  
  78.   parameters  cTitle,cDisplay,cReturn,;
  79.               cKey,;
  80.               nFromRow,nFromCol,nToRow,nToCol,;
  81.               cColor1, cColor2
  82.   private all except *_*
  83.   private all like x_ClrP*
  84.  
  85.  
  86.   * Check validity of all parameters
  87.   if pcount()<3
  88.     return "***"+program()+" Error***"
  89.   endif
  90.  
  91.   * Save setting of TALK and turn it off.
  92.   if set("TALK")="ON"
  93.     set talk off
  94.     cTalk     = "ON"
  95.    else
  96.     cTalk     = "OFF"
  97.   endif
  98.  
  99.   * Save and change settings of other parameters
  100.   cConsole    = set("CONSOLE")
  101.   cCursor     = set("CURSOR")
  102.   cEscape     = set("ESCAPE")
  103.   set cursor        off
  104.   set escape        off
  105.  
  106.   * Set default values for unspecified parameters
  107.   if type("cKey")="L"
  108.     cKey      = ""
  109.   endif
  110.   if type("nFromRow")="L"
  111.     nFromRow  = 5
  112.   endif
  113.   if type("nFromCol")="L"
  114.     nFromCol  = 5
  115.   endif
  116.  
  117.   if type("cColor1")="L"
  118.       x_ClrPMess  = "W+/RB"
  119.       x_ClrPTitl  = "W+/RB"
  120.       x_ClrPBox   = "RG+/RB"
  121.   else
  122.      x_ClrPMess  = colorbrk(cColor1,1)
  123.      x_ClrPTitl  = colorbrk(cColor1,2)
  124.      x_ClrPBox   = colorbrk(cColor1,3) 
  125.   endif
  126.   if type("cColor2")="L"
  127.      x_ClrPHigh  = "G+/N"
  128.      x_ClrPSlct  = "R+/N"
  129.   else
  130.      x_ClrPHigh  = colorbrk(cColor2,1)
  131.      x_ClrPSlct  = colorbrk(cColor2,2)
  132.   endif
  133.  
  134.   *-- Real code starts here
  135.   * Setup specified database environment
  136.   if .not.isblank(cKey)
  137.     set key to cKey
  138.   endif
  139.  
  140.   * Calculate value of nToRow
  141.   if type("nToRow")="L"
  142.     goto top
  143.     count to nToRow next 21-nFromRow
  144.     nToRow    = nFromRow + max(nToRow,3) + 3
  145.   endif
  146.  
  147.   * Calculate value of nToCol
  148.   if type("nToCol")="L"
  149.     nToCol    = nFromCol + max(len(cTitle),len(&cDisplay.)) + 1
  150.     if nToCol>79
  151.       nToCol  = 79
  152.     endif
  153.   endif
  154.  
  155.   * Define and activate title window, draw border and title
  156.   define window wPickList1 from nFromRow,nFromCol to nToRow,nToCol none ;
  157.     color &x_ClrPMess.
  158.   activate window wPickList1
  159.   nWindRow  = nToRow - nFromRow
  160.   nWindCol  = nToCol - nFromCol
  161.   @ 00,00 to nWindRow,nWindCol  color &x_ClrPBox.
  162.   @ 01,01 say cTitle            color &x_ClrPTitl.
  163.   @ 02,01 to 02,nWindCol-1      color &x_ClrPBox.
  164.   cBorder = set("BORDER")
  165.   do case
  166.     case cBorder="NONE"
  167.     case cBorder="SINGLE"
  168.       @ 02,00       say "├"                             color &x_ClrPBox.
  169.       @ 02,nWindCol say "┤"                             color &x_ClrPBox.
  170.     case cBorder="DOUBLE"
  171.       @ 02,00       say "╠"                             color &x_ClrPBox.
  172.       @ 02,nWindCol say "╣"                             color &x_ClrPBox.
  173.     case cBorder="PANEL"
  174.       @ 02,00       say "█"                             color &x_ClrPBox.
  175.       @ 02,nWindCol say "█"                             color &x_ClrPBox.
  176.     otherwise
  177.       @ 02,00       say chr(val(substr(cBorder,17,3)))  color &x_ClrPBox.
  178.       @ 02,nWindCol say chr(val(substr(cBorder,21,3)))  color &x_ClrPBox.
  179.   endcase
  180.  
  181.   * Define and activate data window
  182.   define window wPickList2 from nFromRow+3,nFromCol+1 to nToRow-1,nToCol-1 none color &x_ClrPMess.
  183.   activate window wPickList2
  184.   nWindRow  = nToRow - nFromRow-4
  185.   nWindCol  = nToCol - nFromCol-2
  186.   cWindPict = replicate('X',nWindCol+1)
  187.  
  188.   * Initialize position and status variables
  189.   goto top
  190.   lBell     = (set("BELL")="ON")
  191.   nCurRow   = 0
  192.   nInkey    = 0
  193.   nNewRow   = 0
  194.   nRecNo    = recno()
  195.   lRepaint  = .t.
  196.   cSeek     = ""
  197.   lSeek     = .F.
  198.   nNewSCur  = 0
  199.   nSeekCur  = 0
  200.   if eof()
  201.     if lBell
  202.       @ 00,00 say chr(7)
  203.     endif
  204.     @ 00,00 say "*** No records to list ***"
  205.     set console off
  206.     wait
  207.     set console on
  208.     cReturn = ""
  209.     nInkey  = 27
  210.   endif
  211.  
  212.  
  213.   *-- Display PickList until Enter .or. Ctrl-Q .or. Ctrl-W or Ctrl-End
  214.   *-- .or. Esc is pressed
  215.   lMore = .T.
  216.   do while lMore
  217.     if lSeek
  218.       seek cKey+cSeek
  219.       nNewSCur    = len(cSeek)
  220.       cStr        = &cDisplay.
  221.       nPos  = at(chr(29),substr(cStr,1,nNewSCur+1))
  222.       do while nPos>0
  223.         cStr      = stuff(cStr,nPos,1," ")
  224.         nNewSCur  = nNewSCur + 1
  225.         nPos      = at(chr(29),substr(cStr,1,nNewSCur+1))
  226.       enddo
  227.       nSeek = recno()                   && Save new record number
  228.       n     = 0                         && Counter
  229.       goto nRecNo                       && Record at top of screen
  230.       * Look to see if new record is on screen
  231.       scan while recno()#nSeek .and. n<nMaxRow
  232.         n = n + 1
  233.       endscan
  234.       if recno()=nSeek                  && New record is on screen
  235.         nNewRow = n                     && Put cursor on new record
  236.        else                             && New record is not on screen
  237.         nNewRow   = 0                   && Put cursor at top of window
  238.         nRecNo    = nSeek               && New record at top of window
  239.         lRepaint  = .T.                 && Redisplay window
  240.       endif
  241.       lSeek = .F.
  242.     endif
  243.  
  244.     if lRepaint .or. nNewRow#nCurRow
  245.       * Hide cursor
  246.       @ nCurRow,00 fill to nCurRow,nWindCol color &x_ClrPMess.
  247.     endif
  248.  
  249.     if lRepaint         && Need to redisplay entire data window
  250.       goto nRecNo                       && Record that should be at top of window
  251.       nMaxRow = 0                       && Number of rows displayed
  252.       scan while nMaxRow<=nWindRow      && nWindRow = number of rows in window
  253.         * Display data
  254.         @ nMaxRow,00 say &cDisplay. picture cWindPict color &x_ClrPMess.
  255.         nMaxRow = nMaxRow + 1           && Increase rows displayed counter
  256.       endscan
  257.       nMaxRow = nMaxRow - 1             && Make rows displayed counter zero-based
  258.  
  259.       if eof() .and. nMaxRow<nWindRow   && Didn't fill window?
  260.         * Clear unused portion of window
  261.         @ nMaxRow+1,00 clear to nWindRow,nWindCol
  262.       endif
  263.     endif
  264.  
  265.     if lRepaint .or. nNewRow#nCurRow .or. nNewSCur#nSeekCur
  266.       nSeekCur  = nNewSCur              && New seek cursor length
  267.       nCurRow   = nNewRow               && New cursor position
  268.       if nCurRow>nMaxRow                && Cursor row invalid? (Caused by PgDn)
  269.         nCurRow = nMaxRow               && Put cursor on last displayed row
  270.       endif
  271.  
  272.       * Display cursor
  273.       if nSeekCur>0
  274.         @ nCurRow,00;
  275.           fill to nCurRow,min(nWindCol,nSeekCur-1);
  276.           color &x_ClrPSlct.
  277.       endif
  278.       if nSeekCur<=nWindCol
  279.         @ nCurRow,max(0,nSeekCur);
  280.           fill to nCurRow,nWindCol;
  281.           color &x_ClrPHigh.
  282.       endif
  283.     endif
  284.  
  285.     lRepaint = .F.                      && Reset redisplay flag
  286.  
  287.     nInkey = inkey(0)                   && Get a key-stroke
  288.     do case
  289.       case nInkey=-400                && Shift-Tab
  290.         if isblank(cSeek)
  291.           if lBell
  292.             @ 00,00 say chr(7)
  293.           endif
  294.          else
  295.           if len(cSeek)=nSeekCur
  296.             cSeek = ""
  297.             lSeek = .T.
  298.            else
  299.             goto nRecNo                   && Record at top of window
  300.             skip nCurRow                  && Cursor row
  301.             * Currently seeked string
  302.             cStr  = substr(&cDisplay.,1,nSeekCur)
  303.             * If the last character is a chr(29)
  304.             if substr(cStr,len(cStr),1)=chr(29)
  305.               * Remove the chr(29)
  306.               cStr  = substr(cStr,1,len(cStr)-1)
  307.             endif
  308.             * If there is a chr(29)
  309.             if chr(29)$cStr
  310.               * Remove everything after the last chr(29)
  311.               cSeek = substr(cSeek,1,len(cSeek)-len(cStr)+RAt(chr(29),cStr))
  312.              else
  313.               * Remove everything
  314.               cSeek = ""
  315.             endif
  316.             lSeek = .T.
  317.           endif
  318.         endif
  319.  
  320.       case nInkey=3                   && PageDown
  321.         cSeek     = ""                    && Clear seek string
  322.         nNewSCur  = 0                     && Clear seek cursor
  323.         if nCurRow=nMaxRow                && Is cursor on last line in window?
  324.           goto nRecNo                     && Record at top of window
  325.           skip nWindRow+1                 && Number of records in window
  326.           if eof()
  327.             if lBell
  328.               @ 00,00 say chr(7)          && No more records past bottom of window
  329.             endif
  330.            else
  331.             skip -1                       && Put bottom record at top of window
  332.             nRecNo    = recno()           && New record for top of window
  333.             lRepaint  = .T.               && Redisplay window
  334.           endif
  335.          else                             && Cursor is not on last line in window
  336.           nNewRow = nMaxRow               && Put cursor on last line in window
  337.         endif
  338.  
  339.       case nInkey=5                   && Up Arrow
  340.         cSeek     = ""                    && Clear seek string
  341.         nNewSCur  = 0                     && Clear seek cursor
  342.         if nCurRow>0                      && Is cursor below top of window?
  343.           nNewRow = nCurRow - 1           && Move cursor up
  344.          else                             && Cursor is at top of window
  345.           goto nRecNo                     && Record at top of window
  346.           skip -1
  347.           if bof()
  348.             if lBell
  349.               @ 00,00 say chr(7)            && No previous record
  350.             endif
  351.            else
  352.             nRecNo    = recno()           && New record for top of window
  353.             lRepaint  = .t.               && Redisplay window
  354.           endif
  355.         endif
  356.  
  357.       case nInkey=9                   && Tab
  358.         goto nRecNo                       && Record at top of window
  359.         skip nCurRow                      && Cursor row
  360.         * Characters after currently seeked string
  361.         cStr  = substr(&cDisplay.,nSeekCur+1)
  362.         if (chr(29)$cStr)                 && Tab marker included?
  363.           * Seek everything up to the tab marker
  364.           cStr  = substr(cStr,1,at(chr(29),cStr)-1)
  365.           if .not.seek(cKey+cSeek+cStr)
  366.             cStr  = upper(cStr)
  367.           endif
  368.           if seek(cKey+cSeek+cStr)
  369.             cSeek = cSeek + cStr
  370.             lSeek = .T.
  371.            else
  372.             if lBell
  373.               @ 00,00 say chr(7)
  374.             endif
  375.           endif
  376.          else
  377.           if lBell
  378.             @ 00,00 say chr(7)
  379.           endif
  380.         endif
  381.  
  382.       case nInkey=13 .or. nInkey=23   && Enter .or. Ctrl-W or Ctrl-End
  383.         goto nRecNo                       && Record at top of window
  384.         skip nCurRow                      && Cursor row
  385.         cReturn = &cReturn.               && Return value
  386.         lMore   = .F.                     && Exit main loop
  387.  
  388.       case nInkey=17 .or. nInkey=27   && Ctrl-Q .or. Escape
  389.         cReturn = ""                      && Return value
  390.         lMore   = .F.                     && Exit main loop
  391.  
  392.       case nInkey=18                  && Page Up
  393.         cSeek     = ""                    && Clear seek string
  394.         nNewSCur  = 0                     && Clear seek cursor
  395.         if nCurRow=0                      && Is cursor on top line of window?
  396.           goto nRecNo                     && Record at top of window
  397.           skip -nWindRow                  && Number of records in window
  398.           if bof()
  399.             if lBell
  400.               @ 00,00 say chr(7)            && No more records above top of window
  401.             endif
  402.            else
  403.             nRecNo    = recno()           && New record for top of window
  404.             lRepaint  = .T.               && Redisplay window
  405.           endif
  406.          else                             && Cursor is not on top line of window
  407.           nNewRow = 0                     && Put cursor on top line of window
  408.         endif
  409.  
  410.       case nInkey=24                  && Down Arrow
  411.         cSeek     = ""                    && Clear seek string
  412.         nNewSCur  = 0                     && Clear seek cursor
  413.         if nCurRow<nMaxRow                && Is cursor above bottom of window?
  414.           nNewRow = nCurRow + 1           && Move cursor down
  415.          else                             && Cursor is at bottom of window
  416.           goto nRecNo                     && Record at top of window
  417.           skip nWindRow+1                 && Skip to first record below window
  418.           if eof()
  419.             if lBell
  420.               @ 00,00 say chr(7)            && No records below window
  421.             endif
  422.            else
  423.             goto nRecNo                   && Record at top of window
  424.             skip +1
  425.             nRecNo    = recno()           && New record for top of window
  426.             lRepaint  = .T.               && Redisplay window
  427.           endif
  428.         endif
  429.  
  430.       case nInkey=2 .or. nInkey=30    && End .or. Ctrl-Page Down
  431.         cSeek     = ""                    && Clear seek string
  432.         nNewSCur  = 0                     && Clear seek cursor
  433.         goto bottom                       && Last record in database
  434.         skip -nWindRow                    && Number of records in window
  435.         nNewRow   = nWindRow              && Put cursor on bottom line of window
  436.         nRecNo    = recno()               && New record for top of window
  437.         lRepaint  = .T.                   && Redisplay window
  438.  
  439.       case nInkey=26 .or. nInkey=31   && Home .or. Ctrl-Page Up
  440.         cSeek     = ""                    && Clear seek string
  441.         nNewSCur  = 0                     && Clear seek cursor
  442.         goto top                          && First record in database
  443.         nNewRow   = 0                     && Put cursor on top line of window
  444.         nRecNo    = recno()               && New record for top of window
  445.         lRepaint  = .T.                   && Redisplay window
  446.  
  447.       case nInkey>31 .and. nInkey<127 && Displayable character - Seek it
  448.         cInkey  = chr(nInkey)
  449.         if .not.seek(cKey+cSeek+cInkey)
  450.           cInkey  = upper(cInkey)
  451.         endif
  452.         if seek(cKey+cSeek+cInkey)        && Seek with new character
  453.           cSeek     = cSeek + cInkey      && Add new character to seek string
  454.           lSeek     = .T.
  455.          else
  456.           if lBell
  457.             @ 00,00 say chr(7)              && Seek with new character failed
  458.           endif
  459.         endif
  460.  
  461.       case nInkey=127                 && Back Space
  462.         if len(cSeek)>0                   && Seek string is non-blank
  463.           * Remove last character from seek string
  464.           cSeek = left(cSeek,len(cSeek)-1)
  465.           lSeek = .T.
  466.          else
  467.           if lBell
  468.             @ 00,00 say chr(7)              && Seek string is blank
  469.           endif
  470.         endif
  471.  
  472.       otherwise                       && Unknown key
  473.         b=.t.                             && Breakpoint - used for debugging
  474.         release b
  475.     endcase
  476.   enddo
  477.  
  478.   * Deactivate and release windows
  479.   deactivate window wPickList2
  480.   deactivate window wPickList1
  481.   release windows wPickList1,wPickList2
  482.  
  483.   * Restore database environment
  484.   if .not.isblank(cKey)
  485.     set key to
  486.   endif
  487.  
  488.   *-- Cleanup
  489.   set console       &cConsole.
  490.   set cursor        &cCursor.
  491.   set escape        &cEscape.
  492.   set talk          &cTalk.
  493.  
  494. RETURN cReturn
  495. *-- EoF: Pick1()
  496.  
  497. FUNCTION Pick2
  498. *-------------------------------------------------------------------------------
  499. *-- Programmer..: Malcolm C. Rubel
  500. *-- Date........: 05/18/1992
  501. *-- Notes.......: I stole ... er ... lifted ... this from Data Based Advisor 
  502. *--               (Nov. 1991), and dUFLPed it, as well as removing the FoxPro 
  503. *--               code ...
  504. *--               It's purpose is to create a popup/picklist that will
  505. *--               find the proper location (used with a GET) on the
  506. *--               screen for itself, display the popup and return the 
  507. *--               appropriate value ...
  508. *-- Written for.: dBASE IV, 1.1
  509. *-- Rev. History: 11/xx/1991 -- Malcom C. Rubel -- Original Code
  510. *--               05/15/1992 -- Ken Mayer -- several things. First, I dUFLPed
  511. *--               the code, and documented it heavier than the original.
  512. *--                Next, I had to write a function (USED()), as there wasn't
  513. *--               one sitting around that I could see. 
  514. *--                I added the 'cTag' parameter, as well as a few minor changes
  515. *--               to the other functions that come with this routine ... 
  516. *--               05/19/1992 -- Resolved a few minor problems, removed routine
  517. *--               PK_SHOW as being unnecessary (used @nGetRow... GET to 
  518. *--               redisplay field/memvar). Added IsBlank() (copy of EMPTY()) to
  519. *--               handle different field types (original only wanted characters).
  520. *-- Calls.......: ScrRow()             Function in SCREEN.PRG (and here)
  521. *--               ScrCol()             Function in SCREEN.PRG (and here)
  522. *--               Used()               Function in FILES.PRG (and here)
  523. *-- Called by...: Any
  524. *-- Usage.......: Pick2("<cLookFile>","<cTag>","<cSrchFld>","<cRetFld>",;
  525. *--                     <nScrRow>,<nScrCol>)
  526. *-- Example.....: @10,20 get author ;
  527. *--                      valid required pick2("Library","Author",;
  528. *--                      "Last","Last",10,20)
  529. *-- Returns.....: lReturn (found/replaced a value or not ...)
  530. *-- Parameters..: cLookFile = file to lookup in
  531. *--               cTag      = MDX Tag to use (if blank, will use the first
  532. *--                           tag in the MDX file, via the TAG(1) option ...)
  533. *--               cSrchFld  = field(s) to browse -- if blank, function will
  534. *--                           try to use a field of same name as what 
  535. *--                           cursor is on.
  536. *--               cRetFld   = name of field value is to be returned from.
  537. *--               nScrRow   = screen-row (of GET) -- if blank, function will
  538. *--                           determine (use ,, to blank it ... or 0)
  539. *--               nScrCol   = screen-col (of GET) -- if blank, function will
  540. *--                           determine
  541. *-------------------------------------------------------------------------------
  542.  
  543.     parameters cLookFile, cTag, cSrchFld, cRetFld, nScrRow, nScrCol
  544.     private cLookFile,cSrchFld,cRetFld,nScrRow,nScrCol,cVarName,xValReturn,;
  545.             lWasOpen,cCurrBuff,lExact,lReturn,lIsFound,;
  546.             cBarFields,nWinWidth,nGetRow,nGetCol
  547.     
  548.     lReturn = .t.                       && return value must be a logical ...
  549.                                         &&   assume the best ...
  550.     cVarName = varread()                && name of the variable at GET
  551.     xVarValue = &cVarName               && value of the variable at GET
  552.     
  553.     *-- was a 'fieldname' to get value from passed to function?
  554.     if isblank(cRetFld)                 && passed as a null
  555.         cRetFld = cSrchFld               && we'll return contents of same name
  556.                                          &&   as the search field
  557.     endif
  558.     
  559.     nScrRow = ScrRow()                  && get row for picklist
  560.     nScrCol = ScrCol()                  && get column for picklist
  561.     cCurrBuff = alias()                 && current buffer (work area)
  562.     lExact = set("EXACT") = "ON"        && store status of 'EXACT'
  563.     set exact on                        && we want 'exact' matches ...
  564.     
  565.     *-- deal with the 'lookup' file -- if not open, open it, if open,
  566.     *-- select it ...
  567.     if .not. used(cLookFile)            && file not open
  568.         select select()                  && find next open area
  569.         use &cLookFile                   && open file
  570.         lWasOpen = .f.
  571.     else
  572.         select (cLookFile)               && file IS open, move to it ...
  573.         lWasOpen = .t.
  574.     endif
  575.     
  576.     *-- deal with MDX tag for 'lookup' file ...
  577.     if len(trim(cTag)) = 0              && if a null tag was sent,
  578.         set order to Tag(1)              && set the order to first tag
  579.     else
  580.         set order to &cTag               && set it to what user passed.
  581.     endif
  582.     
  583.     *-- screen positions ...
  584.     nGetRow = row()                     && position of 'get' on screen
  585.     nGetCol = iif(isblank(xVarValue),col(),col()-len(&cRetFld))
  586.                                         && get column of 'get' ...
  587.     
  588.     *-- if field is empty, do a lookup, otherwise, look for it in table
  589.     if isblank(xVarValue)               && no data in field
  590.         lIsFound = .f.                   && automatic lookup
  591.     else
  592.         lIsFound = seek(xVarValue)       && look for it in table
  593.     endif
  594.     
  595.     *-- if not found, or field was empty, bring up the lookup ...
  596.     if .not. lIsFound                   && not in table
  597.         go top                           && move pointer to top of 'table'
  598.         *-- make sure it fits on screen
  599.         if cRetFld = cSrchFld            && one browse field
  600.             nWinWidth = len(&cSrchFld) + 3 && width
  601.             cBarFields = cSrchFld         && set the 'browse fields'
  602.         else                             && else multiple ....
  603.             nWinWidth = len(&cSrchFld)+len(&cRetFld)+5
  604.             cBarFields = cSrchFld+", "+cRetFld
  605.         endif
  606.         
  607.         *-- this is how we determine where to start the browse table ...
  608.         nScrCol = iif(nScrCol+nWinWidth>77,77-nWinWidth,nScrCol)
  609.         nScrRow = iif(nScrRow>14,14,nScrRow)
  610.         
  611.         *-- set it up ...
  612.         define window wPick from nScrRow,nScrCol+2 to ;
  613.             nScrRow+10,nScrCol+nWinWidth+2 panel
  614.         activate window wPick
  615.         *on key label ctrl-m keyboard chr(23) && when user presses <enter>,
  616.                                              && force an <enter> ... weird.
  617.         
  618.         *-- activate
  619.         browse fields &cBarFields freeze &cSrchFld noedit noappend;
  620.             nodelete nomenu window wPick
  621.         clear typeahead                  && in case they pressed the <Enter> key
  622.         
  623.         on key label ctrl-m              && reset
  624.         
  625.         release window wPick
  626.         
  627.         if lastkey() # 27                && not the <Esc> key
  628.             store &cRetFld to &cVarName   && put return value into var ...
  629.         else
  630.             lReturn = .F.
  631.         endif
  632.     else
  633.         store &cRetFld to &cVarName
  634.     endif
  635.     
  636.     @nGetRow, nGetCol get &cVarName     && display new value in field/memvar
  637.                                         &&  on screen
  638.     clear gets                          && clear gets from this function
  639.     
  640.     *-- reset work areas, and so on ...
  641.     if .not. lExact
  642.         set exact off
  643.     endif
  644.     if .not. lWasOpen
  645.         use
  646.     endif
  647.     if len(cCurrBuff) # 0
  648.         select (cCurrBuff)
  649.     else
  650.         select select()
  651.     endif
  652.     
  653. RETURN (lReturn)
  654. *-- EoF: Pick2()
  655.  
  656. FUNCTION ScrRow
  657. *-------------------------------------------------------------------------------
  658. *-- Programmer..: Malcolm C. Rubel
  659. *-- Date........: 11/xx/1991
  660. *-- Notes.......: Returns the postion of the current 'GET'. If memvar
  661. *--               nScrRow already exists, returns the value of that, unless
  662. *--               it's zero, in which case we return the current position.
  663. *--               This is part of PICK2.
  664. *-- Written for.: dBASE IV, 1.1
  665. *-- Rev. History: 05/15/1992 -- Ken Mayer (KENMAYER) to deal with a value of
  666. *--               0 for the nScrRow memvar.
  667. *-- Calls.......: None
  668. *-- Called by...: Pick2()              Function in PICKLIST.PRG
  669. *-- Usage.......: ScrRow()
  670. *-- Example.....: nScrRow = ScrRow()
  671. *-- Returns.....: Numeric -- position of cursor on screen
  672. *-- Parameters..: None
  673. *-------------------------------------------------------------------------------
  674.  
  675.     if type('nScrRow') # 'N' .or. nScrRow = 0
  676.         RETURN (row())
  677.     else
  678.         RETURN (nScrRow)
  679.     endif
  680. *-- EoF: ScrRow()
  681.     
  682. FUNCTION ScrCol
  683. *-------------------------------------------------------------------------------
  684. *-- Programmer..: Malcolm C. Rubel
  685. *-- Date........: 11/xx/1991
  686. *-- Notes.......: Returns the postion of the current 'GET'. If memvar
  687. *--               nScrCol already exists, returns the value of that, unless
  688. *--               it's zero, in which case we return the current position.
  689. *--               This will also return a different value based on whether or
  690. *--               not the field has something in it or not ... This is part of
  691. *--               PICK2.
  692. *-- Written for.: dBASE IV, 1.1
  693. *-- Rev. History: 05/15/1992 -- Ken Mayer (KENMAYER) to deal with a value of
  694. *--               0 for the nScrCol memvar.
  695. *-- Calls.......: None
  696. *-- Called By...: Pick2()
  697. *-- Usage.......: ScrCol()
  698. *-- Example.....: nScrCol = ScrCol()
  699. *-- Returns.....: Numeric -- position of cursor on screen
  700. *-- Parameters..: None
  701. *-------------------------------------------------------------------------------
  702.  
  703.     if type('nScrCol') # 'N' .or. nScrCol = 0
  704.         if isblank(cRetFld)
  705.             RETURN col() + len(cRetFld)
  706.         else
  707.             RETURN col()
  708.         endif
  709.     else
  710.         RETURN (nScrCol)
  711.     endif
  712.     
  713. *-- EoF: ScrCol()
  714.  
  715. PROCEDURE Pick3
  716. *-------------------------------------------------------------------------------
  717. *-- Programmer..: Martin Leon (HMAN) (A-T)
  718. *-- Date........: 11/xx/1990
  719. *-- Notes.......: A "generic" PickList routine ...
  720. *-- Written for.: dBASE IV, 1.1
  721. *-- Rev. History: Published in TechNotes, November, 1990 (DIYPOPUP)
  722. *--               Modified for dHUNG/dUFLP standards, Ken Mayer, 7/12/91
  723. *-- Calls.......: None
  724. *-- Called by...: Any
  725. *-- Usage.......: do Pick3 with "<cFields>",<nULRow>,<nULCol>,<nBRRow>,;
  726. *--                <nBRCol>, "<cNormColor>","<cFieldColor>","<cBorder>"
  727. *-- Example.....: Do Pick3 with "First_name+' '+Last_name",5,10,15,60,;
  728. *--                "rg+/gb","gb/r","DOUBLE"
  729. *-- Returns.....: indirectly returns the record pointer of record that was
  730. *--                 highlighted when <Enter> was pressed.
  731. *-- Parameters..: cFields     = fields to be displayed in picklist
  732. *--               nULRow      = Row coordinate of upper left corner
  733. *--               nULCol      = Column coordinate of upper left corner
  734. *--               nBRRow      = Row coordinate of lower right corner
  735. *--               nBRCol      = Column coordinate of lower right corner
  736. *--               cNormColor  = Foreground/Background of normal text
  737. *--               cFieldColor = Foreground/Background of highlighted fields
  738. *--               cBorder     = NONE, SINGLE, DOUBLE (defaults to Single if
  739. *--                               sent as a nul string ("") )
  740. *-------------------------------------------------------------------------------
  741.     parameter cFields, nULRow, nULCol, nBRRow, nBRCol, cNormColor, ;
  742.             cFieldColor, cBorder
  743.  
  744.     cCursor = set("CURSOR")
  745.     cEscape = set("ESCAPE")
  746.     cTalk   = set("TALK")
  747.     set cursor off
  748.     set escape off
  749.     set talk off
  750.     cTypeCheck = type("cFields")+type("nULRow")+type("nULCol")+type("nBRRow")+ ;
  751.         type("nBRCol")+type("cNormColor")+type("cFieldColor")+type("cBorder")
  752.  
  753.     lError = .F.
  754.     do case
  755.         && Check data types
  756.         case cTypeCheck # "CNNNNCCC"
  757.             clear
  758.             @ 7,17 say "Data type mismatch -- check all parameters"
  759.             lError = .T.
  760.         
  761.         && Check for bottom limit with STatUS ON
  762.         case ((nBRRow >21 .and. set("DISPLAY") # "EGA43")    ;
  763.                 .or. (nBRRow >39 .and. set("DISPLAY") = "EGA43")) ;
  764.                 .and. set("STatUS") = "ON"
  765.             clear
  766.             @ 7,15 say "Cannot use this popup on or below STatUS line"
  767.             lError = .T.
  768.         
  769.         && Check for bottom limit with STatUS ofF
  770.         case ((nBRRow >24 .and. set("DISPLAY") # "EGA43")    ;
  771.                 .or. (nBRRow >42 .and. set("DISPLAY") = "EGA43")) ;
  772.                 .and. set("STatUS") = "ofF"
  773.             clear
  774.             @ 7,16 say "Bottom coordinate beyond bottom of screen"
  775.             lError = .T.
  776.         
  777.         && Check left & right coordinates
  778.         case nULCol < 0 .or. nBRCol > 79
  779.             clear
  780.             @ 7,24 say "Invalid Column coordinate"
  781.             lError = .T.
  782.     
  783.         && Check to make sure popup can display at least one record
  784.         case nBRRow - nULRow < 2
  785.             clear
  786.             @ 7,19 say "Popup must be at least 3 lines high"
  787.             lError = .T.
  788.         
  789.     endcase
  790.  
  791.     if lError
  792.         @ 5,5 to 9,70 double
  793.         @ 11, 32 say "Press Any Key"
  794.         nX = 0
  795.         do while nX = 0
  796.             nX = inkey()
  797.         enddo
  798.         set cursor &cCursor
  799.         set escape &cEscape
  800.         set talk &cTalk
  801.         return
  802.     endif
  803.  
  804.     && Save colors of normal and fields to restor when done
  805.     cFieldset = set("ATTRIBUTES")
  806.     cNormSet = left(cFieldset, at(",",cFieldset)-1)
  807.     do while "," $ cFieldset
  808.         cFieldset = substr(cFieldset, at(",",cFieldset)+1)
  809.     enddo
  810.  
  811.     && If they were provided, set to colors passed on from calling program
  812.     if len(cNormColor) # 0
  813.         set color of normal to &cNormColor
  814.     endif
  815.     if len(cFieldColor) # 0
  816.         set color of fields to &cFieldColor
  817.     endif
  818.  
  819.     nPromptW = nBRCol - nULCol - 1
  820.     @ nULRow, nULCol clear to nBRRow, nBRCol 
  821.     @ nULRow, nULCol to nBRRow, nBRCol &cBorder
  822.  
  823.     if eof()
  824.        skip -1
  825.     endif
  826.  
  827.     && Save current record pointer and determine record number of top record
  828.     nTmpRec = recno()
  829.     go top
  830.     nTopRec = recno()
  831.     go nTmpRec
  832.     nMaxRecs = nBRRow - nULRow - 1
  833.     nKey = 0
  834.     lGoBack = .F.
  835.     declare aPrompt[nMaxRecs], aRec[nMaxRecs]
  836.  
  837.     do while .not. lGoBack
  838.         nChcNum = 1
  839.         nTopRow = nULRow + 1
  840.         nLeftCol = nULCol + 1
  841.         nRowOffset = 0
  842.         nLastCurs = 0
  843.  
  844.         && This loop puts text into prompts
  845.         do while nRowOffset + 1 <= nMaxRecs
  846.             if .not. eof()
  847.                 cTemp = &cFields        && Expands cFields into string expression
  848.                 aPrompt[nChcNum] = substr(cTemp, 1, nPromptW)
  849.             
  850.                 && If prompt doesn't fill entire box, add spaces
  851.                 if len(aPrompt[nChcNum]) < nPromptW
  852.                     aPrompt[nChcNum] = aPrompt[nChcNum] + ;
  853.                         space(nPromptW - len(aPrompt[nChcNum]))
  854.                 endif
  855.  
  856.                 aRec[nChcNum] = recno()
  857.                 @ nTopRow+nRowOffset , nLeftCol say aPrompt[nChcNum]
  858.             endif
  859.             nRowOffset = nRowOffset + 1
  860.             nChcNum = nChcNum + 1
  861.             skip
  862.         
  863.             && If last record reached, clear rest of box
  864.             if eof()
  865.                 do while nRowOffset + 1 <= nMaxRecs
  866.                     @ nTopRow+nRowOffset, nLeftCol say space(nPromptW)
  867.                     nRowOffset = nRowOffset +1
  868.                 enddo
  869.                 exit
  870.             endif
  871.         enddo
  872.     
  873.         nHighChc = nChcNum - 1
  874.         if nKey # 2 .and. nKey # 3   && if the last key pressed wasn't <end>
  875.             nChcNum = 1               && or <PgDn>
  876.             nRowOffset = 0
  877.         else
  878.             nChcNum = nHighChc
  879.             nRowOffset = nHighChc - 1
  880.         endif
  881.     
  882.         @ nTopRow+nRowOffset , nLeftCol get aPrompt[nChcNum]
  883.         clear gets
  884.     
  885.         && This loops traps the keys
  886.         do while .T.
  887.             nKey = inkey()
  888.             do case
  889.         
  890.                 case nKey = 5   && Up arrow
  891.                 
  892.                     && If first record displayed is first record in database
  893.                     && and it is already highlighted
  894.                     if aRec[1] = nTopRec .and. nChcNum = 1
  895.                         loop
  896.                     endif
  897.                 
  898.                     && If first record is highlighted but is not top record,
  899.                     && shift prompt contents down
  900.                     if aRec[1] # nTopRec .and. nChcNum = 1
  901.                         go aRec[1]
  902.                         nX = nHighChc 
  903.                         do while nX > 1
  904.                             aRec[nX] = aRec[nX - 1]
  905.                             aPrompt[nX] = aPrompt[nX - 1]
  906.                             nX = nX - 1
  907.                         enddo
  908.                     
  909.                         && Get prompt for additional record to be displayed
  910.                         skip -1
  911.                         aRec[1] = recno()
  912.                         cTemp = &cFields
  913.                         aPrompt[1] = substr(cTemp, 1, nPromptW)
  914.                         if len(aPrompt[1]) < nPromptW
  915.                             aPrompt[1] = aPrompt[1] + ;
  916.                                 space(nPromptW - len(aPrompt[1]))
  917.                         endif
  918.                         skip + nMaxRecs
  919.                     
  920.                         && If maximum possible records aren't displayed
  921.                         if nHighChc < nMaxRecs
  922.                             nHighChc = nHighChc + 1
  923.                             skip -1
  924.                             aRec[nHighChc] = recno()
  925.                             cTemp = &cFields
  926.                             aPrompt[nHighChc] = substr(cTemp, 1, nPromptW)
  927.                             if len(aPrompt[nHighChc]) < nPromptW
  928.                                 aPrompt[nHighChc] = aPrompt[nHighChc] + ;
  929.                                 space(nPromptW - len(aPrompt[nHighChc]))
  930.                             endif
  931.                             skip
  932.                         endif
  933.                     
  934.                         && Redisplay prompts with new contents
  935.                         nX = 1
  936.                         do while nX < nHighChc + 1
  937.                             @ nTopRow + nX - 1, nLeftCol say aPrompt[nX]
  938.                             nX = nX + 1
  939.                         enddo
  940.                         nChcNum = 2
  941.                     endif
  942.                 
  943.                    nChcNum = iif(nChcNum = 1, nHighChc, nChcNum - 1)
  944.                    nRowOffset = iif(nChcNum = 1, 0, nChcNum - 1)
  945.                    nLastOne = iif(nChcNum = nHighChc, 1, nChcNum+1)
  946.                    nThisOne = nChcNum
  947.  
  948.                    @ nTopRow+iif(nChcNum = nHighChc, 0, nRowOffset+1) , ;
  949.                       nLeftCol say aPrompt[nLastOne]
  950.                    @ nTopRow+nRowOffset , nLeftCol get aPrompt[nThisOne]
  951.                    clear gets
  952.  
  953.                 case nKey = 24   && Dn arrow
  954.                 
  955.                     && If last prompt is highlighted and it is last record
  956.                     if eof() .and. nChcNum = nHighChc
  957.                         loop
  958.                     endif
  959.                 
  960.                     && If not at last record and bottom prompt is highlighted,
  961.                     && shift prompt contents up
  962.                     if .not. eof() .and. nChcNum = nHighChc
  963.                         nX = 1
  964.                         do while nX < nMaxRecs
  965.                             aRec[nX] = aRec[nX + 1]
  966.                             aPrompt[nX] = aPrompt[nX + 1]
  967.                             nX = nX + 1
  968.                         enddo
  969.                     
  970.                         && Get prompt for additional record to be displayed
  971.                         aRec[nMaxRecs] = recno()
  972.                         cTemp = &cFields
  973.                         aPrompt[nMaxRecs] = substr(cTemp, 1, nPromptW)
  974.                         if len(aPrompt[nMaxRecs]) < nPromptW
  975.                             aPrompt[nMaxRecs] = aPrompt[nMaxRecs] + ;
  976.                                 space(nPromptW - len(aPrompt[nMaxRecs]))
  977.                         endif
  978.                         skip
  979.                     
  980.                         && Redisplay prompts with new contents
  981.                         nX = nMaxRecs
  982.                         do while nX > 0
  983.                             @ nTopRow + nX - 1, nLeftCol say aPrompt[nX]
  984.                             nX = nX - 1
  985.                         enddo
  986.                         nChcNum = nMaxRecs - 1
  987.                     endif
  988.                 
  989.                    nChcNum = iif(nChcNum < nHighChc, nChcNum + 1, 1)
  990.                    nRowOffset = iif(nChcNum = 1, 0, nChcNum - 1)
  991.                    nLastOne = iif(nChcNum = 1, nHighChc, nChcNum-1)
  992.                    nThisOne = nChcNum
  993.  
  994.                    @ nTopRow+iif(nChcNum = 1, nHighChc-1, nRowOffset-1) , ;
  995.                       nLeftCol say aPrompt[nLastOne]
  996.                    @ nTopRow+nRowOffset , nLeftCol get aPrompt[nThisOne]
  997.                    clear gets
  998.  
  999.                 case nKey = 13   && Enter key
  1000.                     && Move record pointer and go back to calling program
  1001.                     go aRec[nChcNum]
  1002.                     lGoBack = .T.
  1003.                     exit
  1004.  
  1005.                 case nKey = 3    && PgDn key
  1006.                 
  1007.                     && If last record in .DBF is displayed but not highlighted,
  1008.                     && move highlight to bottom and wait for next key 
  1009.                     if eof() .and. nChcNum # nHighChc
  1010.                   @ nTopRow + nRowOffset, nLeftCol say aPrompt[nChcNum]
  1011.                         @ nTopRow + nHighChc - 1, nLeftCol get aPrompt[nHighChc]
  1012.                         clear gets
  1013.                         nChcNum = nHighChc
  1014.                   nRowOffset = nChcNum - 1
  1015.                         loop
  1016.                     endif
  1017.                 
  1018.                     && If highlight is not on last record that is displayed,
  1019.                     && move highlight to it and wait for next key
  1020.                     if nChcNum # nHighChc
  1021.                   @ nTopRow + nRowOffset, nLeftCol say aPrompt[nChcNum]
  1022.                         @ nTopRow + nHighChc - 1, nLeftCol get aPrompt[nHighChc]
  1023.                         clear gets
  1024.                         nChcNum = nHighChc
  1025.                   nRowOffset = nChcNum - 1
  1026.                   loop
  1027.                     endif
  1028.                 
  1029.                     && Highlight is at bottom record displayed but not at eof
  1030.                     && Move record pointer down to next "page" of records and
  1031.                     && return to main loop
  1032.                     if .not. eof()
  1033.                         go aRec[1]
  1034.                         skip + nMaxRecs
  1035.                         lGoBack = .F.
  1036.                         exit
  1037.                     endif
  1038.                 
  1039.                     && If none of the above is true, wait for another key
  1040.                     loop
  1041.  
  1042.                 case nKey = 18    && PgUp key
  1043.                 
  1044.                     && If top record displayed is top of .DBF but it is
  1045.                     && not highlighted, move highlight to it and wait for next key
  1046.                     if aRec[1] = nTopRec .and. nChcNum # 1
  1047.                    @ nTopRow + nRowOffset, nLeftCol say aPrompt[nChcNum]
  1048.                         @ nTopRow, nLeftCol get aPrompt[1]
  1049.                         clear gets
  1050.                         nChcNum = 1
  1051.                   nRowOffset = 0
  1052.                   loop
  1053.                     endif
  1054.                 
  1055.                     && If highlight is not on top record displayed, move 
  1056.                     && highlight to it and wait for next key
  1057.                     if nChcNum # 1
  1058.                   @ nTopRow + nRowOffset, nLeftCol say aPrompt[nChcNum]
  1059.                         @ nTopRow, nLeftCol get aPrompt[1]
  1060.                         clear gets
  1061.                         nChcNum = 1
  1062.                   nRowOffset = 0
  1063.                         loop
  1064.                     endif
  1065.                 
  1066.                     && Highlight is at top record displayed but not at top of DBF.
  1067.                     && Move record pointer up one "page" worth of records and 
  1068.                     && return to main loop to display new prompts
  1069.                     if aRec[1] # nTopRec
  1070.                         go aRec[1]
  1071.                         skip - nMaxRecs
  1072.                         lGoBack = .F.
  1073.                         exit
  1074.                     endif
  1075.                 
  1076.                     && If none of the above is true, wait for next key
  1077.                     loop
  1078.                 
  1079.                 case nKey = 27   && Esc key
  1080.                     && Move record pointer to where it was before starting this
  1081.                     && routine and return to calling program
  1082.                     lAbandon = .T.
  1083.                     lGoBack = .T.
  1084.                     go nTmpRec
  1085.                     exit
  1086.  
  1087.                 case nKey = 26    && Home key
  1088.                 
  1089.                     && If already at top of DBF, wait for next key
  1090.                     if aRec[1] = nTopRec
  1091.                     loop
  1092.                  else && go top and return to main loop to display new prompts
  1093.                         go top
  1094.                         lGoBack = .F.
  1095.                         exit
  1096.                     endif
  1097.  
  1098.                 case nKey = 2    && End key
  1099.             
  1100.                     && If last record in DBF is displayed but not highlighted,
  1101.                     && move highlight to it and wait for next key
  1102.                     if eof() .and. nChcNum # nHighChc
  1103.                   @ nTopRow + nRowOffset, nLeftCol say aPrompt[nChcNum]
  1104.                         @ nTopRow + nHighChc - 1, nLeftCol get aPrompt[nHighChc]
  1105.                         clear gets
  1106.                         nChcNum = nHighChc
  1107.                   nRowOffset = nChcNum - 1
  1108.                        loop
  1109.                     endif
  1110.                 
  1111.                     && If last record is not displayed, go to it and 
  1112.                     &&    return to main loop
  1113.                     if .not. eof()
  1114.                         go BOTtoM
  1115.                         skip - (nMaxRecs - 1)
  1116.                         lGoBack = .F.
  1117.                         exit
  1118.                     endif
  1119.                 
  1120.                     && If none of the above is true, go back and wait for next key
  1121.                     loop
  1122.  
  1123.                 case nKey = 28  && F1 key
  1124.                     && This is just sample code for the F1 key
  1125.                     define window TempWin from 5,4 to 14,75
  1126.                     activate window TempWin
  1127.                     @ 1,3 say "Use cursor keys to choose. Press <Enter> to move record pointer"
  1128.                     @ 2,5 say "Use <PgUp>, <PgDn>, <Home>, and <End> to see other records"
  1129.                     @ 3,26 say "Use <Esc> to abandon"
  1130.                     @ 5,23 say "Press Any Key to Continue"
  1131.                     nX = 0
  1132.                     do while nX = 0
  1133.                         nX = inkey()
  1134.                     enddo
  1135.                     deactivate window TempWin
  1136.             
  1137.                 case nKey = -1  && F2 key
  1138.                     && This is just sample code for the F2 key
  1139.                     save screen to sScreen
  1140.                     nX = recno()
  1141.                     go aRec[nChcNum]
  1142.                     set cursor ON
  1143.                 edit nomenu noappend nodelete next 1
  1144.                     * READ is better if you already have a FORMat set.
  1145.                set cursor off
  1146.                go aRec[nChcNum]
  1147.                cTemp = &cFields  && Expands cFields into string expression
  1148.                     aPrompt[nChcNum] = substr(cTemp, 1, nPromptW)
  1149.                     if len(aPrompt[nChcNum]) < nPromptW
  1150.                         aPrompt[nChcNum] = aPrompt[nChcNum] + ;
  1151.                         space(nPromptW - len(aPrompt[nChcNum]))
  1152.                     endif
  1153.                restore screen from sScreen
  1154.                     @ nTopRow+nRowOffset, nLeftCol get aPrompt[nChcNum]
  1155.                clear gets
  1156.                if nX <= reccount()
  1157.                         go nX
  1158.                     else
  1159.                         go bott
  1160.                         skip
  1161.                     endif
  1162.             endcase
  1163.         enddo
  1164.     enddo
  1165.  
  1166.     && Put colors back to what they were and set CURSOR, escape, and TALK back
  1167.     set color of normal to &cNormSet
  1168.     set color of fields to &cFieldset
  1169.     set cursor &cCursor
  1170.     set escape &cEscape
  1171.     set talk &cTalk
  1172.     
  1173. RETURN
  1174. *-- EOP: Pick3
  1175.  
  1176. FUNCTION Pick4
  1177. *-------------------------------------------------------------------------------
  1178. *-- Programmer..: Keith G. Chuvala (CIS: 71600,2033)
  1179. *-- Date........: 02/16/1993
  1180. *-- Notes.......: This is a generic picklist routine.
  1181. *-- Written for.: dBASE IV, 1.1
  1182. *-- Rev. History: 10/01/1992 -- Original version
  1183. *--               11/03/1992 -- Modified to dUFLP it (and use RECOLOR to
  1184. *--                ensure that colors are returned properly) -- Ken Mayer
  1185. *--               02/16/1993 -- Minor changes to deal with small data files
  1186. *--                by Keith.
  1187. *-- Calls.......: ReColor              PROCEDURE in PROC.PRG
  1188. *-- Called by...: Any
  1189. *-- Usage.......: Pick4(nRow,nCol,cTitle,cFileSpecs,cListWhat,nRetChar,;
  1190. *--                     nRetType,cColors
  1191. *-- Example.....: ?Pick4(10,10,"Order Stock","Stock,InvNum",;
  1192. *--                     "left(invno,10)+' '+desc",4,1,"r/w,b/w,w/b")
  1193. *-- Returns.....: number of characters from prompt()
  1194. *-- Parameters..: nRow        = Upper Left Corner Row
  1195. *--               nCol        = Upper Left Corner Column
  1196. *--               cTitle      = Title to display at top of list
  1197. *--               cFileSpecs  = "FILENAME,ORDER,SET_KEY_TO"
  1198. *--               cListWhat   = What should display as prompt
  1199. *--               nRetChar    = Number of characters of prompt to return
  1200. *--               nReturnType = 0 = KEYB(), 1 = Normal Return
  1201. *--               cColors     = Background/Unselected Items,;
  1202. *--                             Selected letters/border, selected bar
  1203. *--                             example: rg+/gb,w+/b,w+/n
  1204. *--                              rg+/gb = unselected items (and background)
  1205. *--                              w+/b   = selected letter(s)
  1206. *--                              w+/n   = currently highlighted bar
  1207. *-------------------------------------------------------------------------------
  1208.  
  1209.    para nRow,nCol,cTitle,cFileSpecs,cListWhat,nRetChar,nReturnType,cColors
  1210.  
  1211.    private nLastBar,cTalk,cStatus,cNColor,cBColor,cHColor,nPick,;
  1212.            cWindow,cCursor,cAlias,sPick,cAttrib,nLastBar, nDone,;
  1213.            nX,nP,nO,aBar,lRefresh,nLCol,nRCol,nPKey,cExact,  ;
  1214.            cSeek,nOldRow,nOldWidth,xRetVal,cSetKey
  1215.  
  1216.     *-- basic environmental stuff
  1217.    cTalk = set("talk")
  1218.    set talk off
  1219.     *-- set default colors
  1220.    cNColor = "w/n"
  1221.    cBColor = "w+/n"
  1222.    cHColor = "n/w"
  1223.     *-- if user passed this parameter
  1224.    if len(cColors) > 0
  1225.       nX = at(",",cColors)
  1226.       cNColor = left(cColors,nX-1)
  1227.       cColors = substr(cColors,nX+1)
  1228.       if len(cColors) > 0
  1229.          nX = at(",",cColors)
  1230.          cBColor = iif(nX > 0,left(cColors,nX-1),cColors)
  1231.          cColors = iif(nX > 0,substr(cColors,nX+1),"")
  1232.          if len(cColors) > 0
  1233.             cHColor = cColors
  1234.         endif
  1235.       endif
  1236.    endif
  1237.     
  1238.     *-- save current screen colors and screen, modify environment some more
  1239.    cAttrib = set("attr")
  1240.    set color to &cHColor,&cNColor
  1241.    save screen to sPick
  1242.    cStatus = set("status")
  1243.    set status off
  1244.    restore screen from sPick
  1245.    cCursor = set("cursor")
  1246.    set cursor off
  1247.    cWindow = window()
  1248.    activate screen
  1249.    cExact = set("exact")
  1250.    cSeek = ""
  1251.    set exact off
  1252.    set near off
  1253.  
  1254.     *-- display
  1255.    @ 9,32 clear to 9,47
  1256.    @ 9,32 fill to 11,49 color w/n
  1257.    @ 8,31 to 10,48 color &cBColor
  1258.    @ 9,32 say " Please wait... " color &cNColor
  1259.     
  1260.     *-- create the picklist
  1261.    declare aBar[10]
  1262.    cOrder = ""
  1263.    cSetKey = ""
  1264.    cFile = cFileSpecs
  1265.    nX = at(",",cFileSpecs)
  1266.    if nX > 0
  1267.       cFile= left(cFileSpecs,nX-1)
  1268.       cFileSpecs = substr(cFileSpecs,nX+1)
  1269.       if len(cFileSpecs) > 0
  1270.          nX = at(",",cFileSpecs)
  1271.          cOrder = iif(nX>0,left(cFileSpecs,nX-1),cFileSpecs)
  1272.          cFileSpecs = iif(nX>0,substr(cFileSpecs,nX+1),"")
  1273.          if len(cFileSpecs) > 0
  1274.             cSetKey = cFileSpecs
  1275.          endif
  1276.       endif
  1277.    endif
  1278.    cAlias = alias()
  1279.    nLastBar = 9
  1280.    nP = 1 
  1281.    nO = 1
  1282.    nDone = 0
  1283.    lRefresh = .t.
  1284.    lSameFile = (cAlias = upper(cFile))
  1285.    use &cFile. again in select() alias picker
  1286.    if len(tag(1)) > 0
  1287.       set order to tag(1)
  1288.    endif
  1289.    set deleted on
  1290.    if len(trim(cOrder)) > 0
  1291.       set order to &cOrder
  1292.    endif
  1293.    if len(trim(cSetKey)) > 0
  1294.       if at(",",cSetKey) > 0
  1295.          cSetKey = "range "+ cSetKey
  1296.       endif
  1297.       set nPKey to &cSetKey
  1298.    endif
  1299.    go top
  1300.    nDone = iif(reccount() < 1,2,0)
  1301.    if nRow > 14
  1302.       nRow = 14
  1303.    endif
  1304.    nOldWidth = -1
  1305.    nOldRow = -1
  1306.    nLastBar = 9
  1307.    do while nDone = 0
  1308.       if lRefresh .and. .not. eof("picker")
  1309.          nWidth = 0
  1310.          nX = 0
  1311.          do while nX < 8 .and. .not. eof("picker")
  1312.             nX = nX + 1
  1313.             aBar[nX] = &cListWhat
  1314.             if len(aBar[nX]) > nWidth
  1315.                nWidth = len(aBar[nX])
  1316.             endif
  1317.             skip 1
  1318.          enddo
  1319.          nLastBar = nX
  1320.          nLCol = nCol
  1321.          nRCol = nLCol + nWidth + 4
  1322.          do while (nRCol > 77) .and. (nLCol > 0)
  1323.             if nLCol > 1
  1324.                nRCol = nRCol - 1
  1325.                nLCol = nLCol - 1
  1326.             else
  1327.                nRCol = 77
  1328.             endif
  1329.          enddo
  1330.          if (nWidth <> nOldWidth) .or. (nLastBar <> nOldRow)
  1331.             restore screen from sPick
  1332.             @ nRow+1, nLCol+1 fill  to ;
  1333.               nRow+nLastBar+2,nRCol+2 color w/n
  1334.             @ nRow  , nLCol         to ;
  1335.               nRow+nLastBar+1,nRCol   color &cBColor
  1336.             @ nRow  , nLCol+1 say '['   color &cBColor
  1337.             @ nRow  , nLCol+2 say cTitle color &cNColor
  1338.             @ nRow  , nLCol+2+len(cTitle) say ']' color &cBColor
  1339.          endif
  1340.          @ nRow+1, nLCol+1 clear to ;
  1341.            nRow+nLastBar  ,nRCol-1
  1342.          @ nRow+1, nLCol+1 fill  to ;
  1343.            nRow+nLastBar  ,nRCol-1 color &cBColor
  1344.          nOldRow = nLastBar
  1345.          nOldWidth = nWidth
  1346.          nX = 1
  1347.          do while nX <= nLastBar
  1348.             @ nX+nRow,nLCol+2 say " "+aBar[nX] color &cNColor
  1349.             nX = nX + 1
  1350.          enddo
  1351.       endif
  1352.       if nP > nLastBar
  1353.          nP = nLastBar
  1354.       endif
  1355.       if nO <= nLastBar
  1356.          @ nRow+nO, nLCol+2 fill to nRow+nO,nRCol-2 color &cNColor
  1357.       endif
  1358.       @ nRow+nP, nLCol+2 fill to nRow+nP,nRCol-2 color &cHColor
  1359.       nX = at(upper(cSeek),upper(aBar[nP]))
  1360.       if nX > 0
  1361.          @ nRow+nP,nLCol+2+nX fill to nRow+nP,nLCol+1+nX+len(cSeek) ;
  1362.            color &cBColor
  1363.       endif
  1364.       nO = nP
  1365.  
  1366.       *-- start processing key strokes ...
  1367.       nPKey = inkey(0)
  1368.       do case
  1369.          case nPKey = 5                                 && up
  1370.             nP = nP - 1
  1371.             if nP < 1
  1372.                nPKey = 18
  1373.                nP = nLastBar
  1374.             endif
  1375.             cSeek = ""
  1376.          case nPKey = 24                                && down
  1377.             nP = nP + 1
  1378.             if nP > nLastBar
  1379.                if .not. eof("picker")
  1380.                   nPKey = 3
  1381.                   nP = 1
  1382.                else
  1383.                   nPKey = 0
  1384.                   nP = nP - 1
  1385.                endif
  1386.             endif
  1387.             cSeek = ""
  1388.       endcase
  1389.       lRefresh = .t.
  1390.       do case
  1391.       case nPKey = 18                                && pgup, up
  1392.          skip - 16
  1393.          if bof()
  1394.             go top
  1395.          endif
  1396.          cSeek = ""
  1397.       case nPKey = 26                                && home
  1398.          go top
  1399.          nP = 1
  1400.          cSeek = ""
  1401.       case nPKey = 2                                 && end
  1402.          go bottom
  1403.          skip - 7
  1404.          if bof()
  1405.             go top
  1406.          else
  1407.             nP = nLastBar
  1408.          endif
  1409.          cSeek = ""
  1410.       case nPKey = 27                                && esc
  1411.          nDone = 1
  1412.       case (nPKey = 13) .or. (nPkey = 23)            && c/r
  1413.          nPick = aBar[nP]
  1414.          nDone = 1
  1415.       case ((nPKey >= asc(" ")) .and. (nPKey <= asc("z"))) .or. (nPKey = 127)
  1416.          if nPKey = 127
  1417.             cSeek = left(cSeek,len(cSeek)-1)
  1418.          else
  1419.             cSeek = cSeek + chr(nPKey)
  1420.          endif
  1421.          if len(trim(tag())) > 0
  1422.             seek(cSeek)
  1423.             if .not. found()
  1424.                seek(upper(cSeek))
  1425.             endif
  1426.          endif
  1427.          if .not. found()
  1428.              cSeek = left(cSeek,len(cSeek)-1)
  1429.              ?? chr(7)
  1430.          endif
  1431.          if len(trim(cSeek)) = 0
  1432.             go top
  1433.          endif
  1434.          lRefresh = .t.
  1435.          nPKey = 3
  1436.       otherwise
  1437.          if (nPKey <> 3)
  1438.             lRefresh = .f.
  1439.          endif
  1440.       endcase
  1441.    enddo
  1442.  
  1443.     *-- return something, unless <Esc> was pressed
  1444.    if nPKey <> 27
  1445.       if nReturnType = 0
  1446.          keyboard chr(26)+chr(25)+left(nPick,nRetChar)+chr(13)
  1447.       endif
  1448.       xRetVal = iif(nReturnType=0,.t.,iif(nPKey=27,"",left(nPick,nRetChar)))
  1449.    else
  1450.       xRetVal = .f.
  1451.    endif
  1452.  
  1453.     *-- cleanup
  1454.    select picker
  1455.    use
  1456.    if len(trim(cAlias)) > 0
  1457.       select (cAlias)
  1458.    endif
  1459.    if len(trim(cWindow)) > 0
  1460.       activate window &cWindow
  1461.    endif
  1462.     do recolor with cAttrib   
  1463.    set status &cStatus
  1464.    set talk &cTalk
  1465.    set cursor &cCursor
  1466.    set exact &cExact
  1467.    restore screen from sPick
  1468.  
  1469. RETURN xRetVal
  1470. *-- EoF: Pick4()
  1471.  
  1472. FUNCTION PopList
  1473. *-------------------------------------------------------------------------------
  1474. *-- Programmer..: Angus Scott-Fleming (CIS: 75500,3223)
  1475. *-- Date........: 11/30/1992
  1476. *-- Notes.......: Display a popup constructed from up to 9 options. The routine
  1477. *--               then keyboards the first characters of the selected option 
  1478. *--               up to the length of the field/memvar) directly into 
  1479. *--               field/memvar. Used in place of the picture function "@M" 
  1480. *--               built-in to dBASE IV. This should be used only in a VALID 
  1481. *--               REQUIRED clause, not a WHEN clause.
  1482. *-- Written for.: dBASE IV, 1.5
  1483. *-- Rev. History: None
  1484. *-- Calls.......: None
  1485. *-- Called by...: Any
  1486. *-- Usage.......: PopList(<cP1>,<cP2>,<cP3>,<cP4>,<cP5>,...<cP9>)
  1487. *-- Example.....: @6,37 get m->cHanded picture "!" valid required;
  1488. *--                     poplist("Right-handed","Left-handed")
  1489. *-- Returns.....: Logical: .T. when variable being read matches options,
  1490. *--                        .F. otherwise
  1491. *-- Parameters..: cP1 = First parameter for list
  1492. *--               ...
  1493. *--               cP9 = Last this is max routine will allow ... number varies, 
  1494. *--                     should always have at least two, otherwise, what's the 
  1495. *--                     point?
  1496. *-------------------------------------------------------------------------------
  1497.     parameters cP1,cP2,cP3,cP4,cP5,cP6,cP7,cP8,cP9
  1498.     private nPopLen,nPop,nPopRow,nPopCol,nPopECol,nPopBRow,nPop,cPopPar,;
  1499.             cPopRead,cPopRet,nPopInLen,cPopInput
  1500.     
  1501.     nPopLen = 0
  1502.     nPop    = 0
  1503.     cPopRead = VarRead()        && get memvar/field being read
  1504.     cPopInput = &cPopRead       && store again?
  1505.     nPopInLen = len(cPopInput)  && get length
  1506.     declare cPopBar[pcount()]   && define array
  1507.     do while nPop < pcount()
  1508.         nPop = nPop + 1
  1509.         cPopPar = "cP"+ltrim(str(nPop))
  1510.         cPopBar[nPop] = &cPopPar
  1511.         nPopLen = max(nPopLen,len(cPopBar[nPop]))
  1512.         if (cPopInput=left(cPopBar[nPop],nPopInLen)) .and. ;
  1513.             (left(cPopBar[nPop],nPopInLen)=cPopInput)
  1514.             RETURN .T.
  1515.         endif
  1516.     enddo
  1517.     
  1518.     *-- set coordinates of popup (checking for edge of screen ...)
  1519.     nPopRow = row()
  1520.     nPopCol = col() + nPopInLen
  1521.     if nPopRow + pCount() + 1 > 24
  1522.         nPopRow = 23-pCount()
  1523.     endif
  1524.     nPopBRow = nPopRow + pcount() + 1
  1525.     if nPopCol + nPopLen > 79
  1526.         nPopCol = 75-nPopLen
  1527.     endif
  1528.     nPopECol = nPopCol + nPopLen + 1
  1529.     
  1530.     *-- define popup
  1531.     save screen to sPopList
  1532.     define popup PopList from nPopRow,nPopCol to nPopBRow,nPopECol
  1533.     nPop = 0
  1534.     do while nPop < pcount()
  1535.         nPop = nPop + 1
  1536.         define bar nPop of PopList prompt cPopBar[nPop]
  1537.     enddo
  1538.     on selection popup PopList deactivate popup
  1539.     activate popup PopList
  1540.     
  1541.     *-- now we have it, let's deal with output
  1542.     cPopRet = left(prompt(),nPopInLen)
  1543.     
  1544.     *-- cleanup screen and memory
  1545.     release popup PopList
  1546.     restore screen from sPopList
  1547.     release screen sPopList
  1548.     
  1549.     *-- replace data in field for user
  1550.     *-- space is necessary for the valid required error about
  1551.     *--        "Editing condition not satisified ..."
  1552.     *-- chr(26) and chr(25) move cursor to "home" and delete contents
  1553.     *-- of field, so new data can be keyboarded in
  1554.     keyboard " "+chr(26)+chr(25)+cPopRet + iif(set("CONFIRM")="ON",chr(13),"")
  1555.     
  1556. RETURN .F.
  1557. *-- EoF: PopList()
  1558.  
  1559. PROCEDURE Diacrit
  1560. *-------------------------------------------------------------------------------
  1561. *-- Programmer..: Ken Mayer (CIS: 71333,1030)
  1562. *-- Date........: 01/27/1993
  1563. *-- Notes.......: Used to insert those letters with diacritical marks into
  1564. *--               your input screens. This routine brings up a picklist with
  1565. *--               all the standard diacrit characters built into the ASCII
  1566. *--               character set. 
  1567. *--               NOTE: To use this routine properly, two things must be
  1568. *--                done first:
  1569. *--                PUBLIC n_RowPop, n_ColPop
  1570. *--                a Call to LocPop() should be made with a WHEN clause in
  1571. *--                the "get". See example below.
  1572. *-- Written for.: dBASE IV, 1.5
  1573. *-- Rev. History: 12/28/1992 -- Original
  1574. *--               01/27/1993 -- Modified (KJM) to cope with data entry WINDOWS
  1575. *--                which includes restoring the active window when done.
  1576. *-- Calls.......: LocPop()             Indirectly. FUNCTION in PICKLIST.PRG
  1577. *-- Called by...: Any (routine with a GET)
  1578. *-- Usage.......: DO Diacrit 
  1579. *-- Example.....: public n_RowPop, n_ColPop         && vital
  1580. *--               @5,10 get cVar when LocPop(5,10)  && vital
  1581. *--               ON KEY LABEL ALT-K DO DIACRIT 
  1582. *--               read
  1583. *--               on key label alt-k  && release definition
  1584. *-- Returns.....: Keyboards character into current "GET"
  1585. *-- Parameters..: None
  1586. *-------------------------------------------------------------------------------
  1587.     
  1588.     private nRow, nCol, nRow2, nCol2, cReturn
  1589.     on key label alt-k ?? chr(7)  && beep if user tries to call again ...
  1590.     
  1591.     *-- first things first, define where it's to display
  1592.     cWindow = window() && save current window if there is one
  1593.     activate screen
  1594.     nRow = n_RowPop   && get values from public memvars
  1595.     nCol = n_ColPop
  1596.     
  1597.     *-- bottom right corner of popup ...
  1598.     nCol2 = nCol + 5
  1599.     nRow2 = nRow + 10
  1600.     
  1601.     *-- define the popup
  1602.     define popup pDiacrit from nRow,nCol to nRow2,nCol2 
  1603.     define bar  1 of pDiacrit prompt " "+chr(142)+" "  && Ä
  1604.     define bar  2 of pDiacrit prompt " "+chr(143)+" "  && Å
  1605.     define bar  3 of pDiacrit prompt " "+chr(146)+" "  && Æ
  1606.     define bar  4 of pDiacrit prompt " "+chr(131)+" "  && â
  1607.     define bar  5 of pDiacrit prompt " "+chr(132)+" "  && ä
  1608.     define bar  6 of pDiacrit prompt " "+chr(133)+" "  && à
  1609.     define bar  7 of pDiacrit prompt " "+chr(134)+" "  && å
  1610.     define bar  8 of pDiacrit prompt " "+chr(160)+" "  && á
  1611.     define bar  9 of pDiacrit prompt " "+chr(145)+" "  && æ
  1612.     define bar 10 of pDiacrit prompt " "+chr(144)+" "  && É
  1613.     define bar 11 of pDiacrit prompt " "+chr(136)+" "  && ê
  1614.     define bar 12 of pDiacrit prompt " "+chr(137)+" "  && ë
  1615.     define bar 13 of pDiacrit prompt " "+chr(138)+" "  && è
  1616.     define bar 14 of pDiacrit prompt " "+chr(130)+" "  && é
  1617.     define bar 15 of pDiacrit prompt " "+chr(139)+" "  && ï
  1618.     define bar 16 of pDiacrit prompt " "+chr(140)+" "  && î
  1619.     define bar 17 of pDiacrit prompt " "+chr(141)+" "  && ì
  1620.     define bar 18 of pDiacrit prompt " "+chr(161)+" "  && í
  1621.     define bar 19 of pDiacrit prompt " "+chr(147)+" "  && ô
  1622.     define bar 20 of pDiacrit prompt " "+chr(148)+" "  && ö
  1623.     define bar 21 of pDiacrit prompt " "+chr(149)+" "  && ò
  1624.     define bar 22 of pDiacrit prompt " "+chr(162)+" "  && ó
  1625.     define bar 23 of pDiacrit prompt " "+chr(153)+" "  && Ö
  1626.     define bar 24 of pDiacrit prompt " "+chr(150)+" "  && û
  1627.     define bar 25 of pDiacrit prompt " "+chr(129)+" "  && ü
  1628.     define bar 26 of pDiacrit prompt " "+chr(151)+" "  && ù
  1629.     define bar 27 of pDiacrit prompt " "+chr(163)+" "  && ú
  1630.     define bar 28 of pDiacrit prompt " "+chr(154)+" "  && Ü
  1631.     define bar 29 of pDiacrit prompt " "+chr(152)+" "  && ÿ
  1632.     define bar 30 of pDiacrit prompt " "+chr(128)+" "  && Ç
  1633.     define bar 31 of pDiacrit prompt " "+chr(165)+" "  && Ñ
  1634.     define bar 32 of pDiacrit prompt " "+chr(164)+" "  && ñ
  1635.     
  1636.     *-- whatta we do with it?
  1637.     on selection popup pDiacrit deactivate popup
  1638.     activate popup pDiacrit
  1639.     cPrompt = prompt()
  1640.     
  1641.     *--            Esc                ->                  <-
  1642.     if lastkey() = 27 .or. lastkey() = 4 .or. lastkey() = 19
  1643.         cReturn = ""
  1644.     else
  1645.         cReturn = substr(cPrompt,2,1)  && get the actual character ...
  1646.     endif
  1647.     
  1648.     *-- remove from memory
  1649.     release popup pDiacrit
  1650.     *-- reactivate window if there was one ...
  1651.     if .not. isblank(cWindow)
  1652.         activate window &cWindow
  1653.     endif
  1654.     *-- put into user's "Get"
  1655.     keyboard cReturn
  1656.     *-- reset ON KEY definition
  1657.     on key label alt-k do diacrit
  1658.     
  1659. RETURN
  1660. *-- EoP: Diacrit
  1661.  
  1662. FUNCTION LocPop
  1663. *-------------------------------------------------------------------------------
  1664. *-- Programmer..: Kenneth Chan (:>Zak<:) (CIS: 71542,2712)
  1665. *-- Date........: 01/28/1993
  1666. *-- Notes.......: Created for diacritical routine above, to determine position
  1667. *--               of current "Get", and then decide whether to place upper
  1668. *--               left coordinates (in public memvars: n_RowPop, n_ColPop)
  1669. *--               of a popup. 
  1670. *-- Written for.: dBASE IV, 1.5
  1671. *-- Rev. History: 12/25/1992 -- Original
  1672. *--               12/28/1992 -- Modified to deal with positioning if get is
  1673. *--                to far to the right on the screen, and so on (Ken Mayer).
  1674. *--               01/28/1993 -- Modified to handle windows on screen, giving
  1675. *--                an absolute address. Requires user to provide coordinates
  1676. *--                for upper left corner of window.
  1677. *-- Calls.......: VidRow()               Function in SCREEN.PRG
  1678. *--               VidCol()               Function in SCREEN.PRG
  1679. *-- Called by...: Diacrit   (Indirectly) Procedure in PICKLIST.PRG
  1680. *-- Usage.......: LocPop(<nWidth>,<nLength>[,<nWBorder>])
  1681. *-- Example.....: @5,10 get cVar when LocPop(5,10)
  1682. *-- Returns.....: logical true
  1683. *-- Parameters..: nWidth   = width of popup
  1684. *--               nLength  = length of popup (how many bars should display on
  1685. *--                           screen -- used to determine if displaying above
  1686. *--                           or below ROW() of GET)
  1687. *--               nWBorder = OPTIONAL -- if there is no border we have to back
  1688. *--                            up one, so put a '0' in here if there is no
  1689. *--                            border, otherwise, ignore this parameter.
  1690. *-------------------------------------------------------------------------------
  1691.     
  1692.     parameters nWidth,nLength, nWBorder
  1693.     private cVar, nRow, nCol
  1694.     
  1695.     *-- get current "GET"
  1696.     cVar = varread()
  1697.     
  1698.     *-- put current position into column/row ... since cursor was just placed
  1699.     *-- into field (assuming called from WHEN clause), we are always on the
  1700.     *-- first character in the GET ...
  1701.     nRow = VidRow()
  1702.     nCol = VidCol() 
  1703.     
  1704.     if type("NWBORDER") # "L" .and. nWBorder = 0
  1705.         nRow = nRow - 1
  1706.         nCol = nCol - 1
  1707.     endif
  1708.     
  1709.     *-- add it all up, see if popup coordinates are off the screen
  1710.     *-- if so, we need to display the popup UNDER the GET
  1711.     if nCol + (len(&cVar)+nWidth+1) > 79 
  1712.         nRow = nRow + 1                 
  1713.         nCol = 79 - nWidth              && put it right up against edge of screen
  1714.     else                               && otherwise, set column position
  1715.         nCol = nCol + len(&cVar) + 1    && add length of memvar/get
  1716.     endif
  1717.     
  1718.     *-- now to see if we're going to go off the bottom of the screen
  1719.     *-- and deal with _that_ -- displaying popup ABOVE the GET.
  1720.     nDisp = val(right(set("DISPLAY"),2))  && (EGAxx ...)
  1721.     if nRow + nLength +2 => nDisp - 1  && check for bottom of screen
  1722.         nRow = nRow - nLength - 2 
  1723.     endif
  1724.     
  1725.     if type("N_ROWPOP") = "U" .or. type("N_ROWPOP") = "L"
  1726.         public n_RowPop,n_ColPop
  1727.     endif
  1728.     n_RowPop = nRow  && set current position ...
  1729.     n_ColPop = nCol
  1730.     
  1731. RETURN .t.
  1732. *-- EoF: LocPop()
  1733.  
  1734. *-------------------------------------------------------------------------------
  1735. *-- Included below are any auxiliary routines needed for those above.
  1736. *-------------------------------------------------------------------------------
  1737.  
  1738. FUNCTION Used
  1739. *-------------------------------------------------------------------------------
  1740. *-- Programmer..: Ken Mayer (CIS: 71333,1030)
  1741. *-- Date........: 02/28/1992
  1742. *-- Notes.......: Created because the picklist routine by Malcolm Rubel
  1743. *--               from DBA Magazine (11/91) calls a function that checks
  1744. *--               to see if a DBF file is open ... 
  1745. *-- Written for.: dBASE IV, 1.5
  1746. *-- Rev. History: 05/15/1992 -- Original
  1747. *--               02/08/1993 -- Discovered (thanks to Jay, and then Malcolm)
  1748. *--               a much simpler way to do this ...
  1749. *-- Called by...: Any
  1750. *-- Calls.......: None
  1751. *-- Usage.......: Used("<cFile>")
  1752. *-- Example.....: if used("Library")
  1753. *--                  select library
  1754. *--               else
  1755. *--                  select select()
  1756. *--                  use library
  1757. *--               endif
  1758. *-- Returns.....: Logical (.t. if file is in use, .f. if not)
  1759. *-- Parameters..: cFile = file to check for
  1760. *-------------------------------------------------------------------------------
  1761.     
  1762.     parameters cFile
  1763.     
  1764. RETURN (select(cFile) # 0)
  1765. *-- EoF: Used()
  1766.  
  1767. FUNCTION VidRow
  1768. *-------------------------------------------------------------------------------
  1769. *-- Programmer..: Ken Mayer (CIS: 71333,1030)
  1770. *-- Date........: 01/28/1993
  1771. *-- Notes.......: Calls VDCURSOR.BIN (David Frankenbach, CIS: 72147,2635)
  1772. *--               to return the ABSOLUTE position of the current ROW on the
  1773. *--               screen, despite any active windows, etc.
  1774. *--               This is based on original routines by David Frankenbach,
  1775. *--               but includes the load/release in one routine, rather
  1776. *--               than requiring three functions to perform this ...
  1777. *--               ***************************
  1778. *--               ** REQUIRES VDCURSOR.BIN **
  1779. *--               ***************************
  1780. *-- Written for.: dBASE IV, 1.5
  1781. *-- Rev. History: None
  1782. *-- Calls.......: VDCURSOR.BIN
  1783. *-- Called by...: Any 
  1784. *-- Usage.......: VidRow()
  1785. *-- Example.....: ?VidRow()
  1786. *-- Returns.....: Numeric ROW position for current row on screen
  1787. *-- Parameters..: None
  1788. *-------------------------------------------------------------------------------
  1789.  
  1790.     private cX
  1791.     
  1792.     cX = space(2)             && define argument memvar
  1793.     load vdcursor             && load the .BIN file
  1794.     call vdcursor with cX     && call it with the memvar
  1795.     release module vdcursor   && release from memory
  1796.  
  1797. RETURN (asc(substr(cX,2))-1) && return the value of the absolute cursor position
  1798. *-- EoF: VidRow()
  1799.  
  1800. FUNCTION VidCol
  1801. *-------------------------------------------------------------------------------
  1802. *-- Programmer..: Ken Mayer (CIS: 71333,1030)
  1803. *-- Date........: 01/28/1993
  1804. *-- Notes.......: Calls VDCURSOR.BIN (David Frankenbach, CIS: 72147,2635)
  1805. *--               to return the ABSOLUTE position of the current COLUMN on the
  1806. *--               screen, despite any active windows, etc.
  1807. *--               This is based on original routines by David Frankenbach,
  1808. *--               but includes the load/release in one routine, rather
  1809. *--               than requiring three functions to perform this ...
  1810. *--               ***************************
  1811. *--               ** REQUIRES VDCURSOR.BIN **
  1812. *--               ***************************
  1813. *-- Written for.: dBASE IV, 1.5
  1814. *-- Rev. History: None
  1815. *-- Calls.......: VDCURSOR.BIN
  1816. *-- Called by...: Any 
  1817. *-- Usage.......: VidCol()
  1818. *-- Example.....: ?VidCol()
  1819. *-- Returns.....: Numeric COLUMN position for current Col on screen
  1820. *-- Parameters..: None
  1821. *-------------------------------------------------------------------------------
  1822.  
  1823.     private cX
  1824.     
  1825.     cX = space(2)             && define argument memvar
  1826.     load vdcursor             && load the .BIN file
  1827.     call vdcursor with cX     && call it with the memvar
  1828.     release module vdcursor   && release from memory
  1829.  
  1830. RETURN (asc(substr(cX,1))-1) && return the value of the absolute cursor position
  1831. *-- EoF: VidCol()
  1832.  
  1833.  
  1834. *-------------------------------------------------------------------------------
  1835. *-- End of File: PICKLIST.PRG
  1836. *-------------------------------------------------------------------------------
  1837.